home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / cobprint.zip / COBPRINT.COB next >
Text File  |  1990-06-24  |  7KB  |  220 lines
  1. 000100 IDENTIFICATION DIVISION.
  2. 000200*
  3. 000300 PROGRAM-ID. COBPRINT.
  4. 000400*
  5. 000410 AUTHOR. JAMES M. STEELMAN JR.
  6. 000420           STEELMAN CONSULTING SERVICES
  7. 000430           1211 RIVER FOREST LANE
  8. 000440           WOODSTOCK, GA 30188
  9. 000441*
  10. 000450*=================================================================
  11. 000460*
  12. 000470*  THE PURPOSE OF THIS PROGRAM IS TO READ A FILE OF 80 CHARACTER
  13. 000480*    RECORDS AND CAUSE THEM TO BE PRINTED WITH PAGE BREAKS AND
  14. 000490*    A HEADER AT THE TOP OF EACH PAGE.
  15. 000492*
  16. 000493*  WILD CARD NAMES ARE SUPPORTED TO SOME DEGREE.
  17. 000494*
  18. 000495*  TO RUN THE PROGRAM ENTER THE FOLLOWING:
  19. 000496*
  20. 000497*  COBPRINT NAME-OF-FILE-TO-BE-PRINTED
  21. 000498*
  22. 000499*=================================================================
  23. 000500*
  24. 000510 ENVIRONMENT DIVISION.
  25. 000600 CONFIGURATION SECTION.
  26. 000700 SOURCE-COMPUTER. IBM-PC.
  27. 000800 OBJECT-COMPUTER. IBM-PC.
  28. 000900*
  29. 001000 INPUT-OUTPUT SECTION.
  30. 001100*
  31. 001200 FILE-CONTROL.
  32. 001300*
  33. 001400       SELECT INFILE ASSIGN TO VARYING INFILE-NAME.
  34. 001500     SELECT OUTFILE ASSIGN TO 'PRN[N]'.
  35. 001600*
  36. 001700 DATA DIVISION.
  37. 001800*
  38. 001900 FILE SECTION.
  39. 002000*
  40. 002100 FD INFILE
  41. 002200       LABEL RECORDS ARE STANDARD
  42. 002300       RECORD CONTAINS 80 CHARACTERS.
  43. 002400 01 INFILE-REC PIC X(80).
  44. 002500*
  45. 002600 FD OUTFILE
  46. 002700       LABEL RECORDS ARE STANDARD
  47. 002800       RECORD CONTAINS 80 CHARACTERS.
  48. 002900 01 OUTFILE-REC PIC X(80).
  49. 003000*
  50. 003100 WORKING-STORAGE SECTION.
  51. 003200*
  52. 003300 01 INFILE-NAME PIC X(79)        VALUE SPACES.
  53. 003400 01 SEARCH-NAME PIC X(79)        VALUE SPACES.
  54. 003500 01 SEARCH-INFO.
  55. 003600        05    SEARCH-STATE PIC X(26).
  56. 003700        05    FILE-SIZE PIC S9(9) COMP-5.
  57. 003800        05    FILE-NAME PIC X(13).
  58. 003900        05 FILE-DATE-TIME.
  59. 004000           07 FILE-DATE.
  60. 004100          09 YEARS PIC S9(4) COMP-5.
  61. 004200          09 MONTHS PIC S9(4) COMP-5.
  62. 004300          09 DAYS PIC S9(4) COMP-5.
  63. 004400           07 FILE-TIME.
  64. 004500          09 HOURS PIC S9(4) COMP-5.
  65. 004600          09 MINUTES PIC S9(4) COMP-5.
  66. 004700          09 SECONDS PIC S9(4) COMP-5.
  67. 004800        05 FILE-ATTR   PIC S9(4) COMP-5 VALUE 32.
  68. 004900 01 FILE-HANDLE PIC S9(04) COMP-5.
  69. 005000 01 FILE-ACCESS-MODE PIC S9(4) COMP-5.
  70. 005100*
  71. 005200 01 HD1.
  72. 005300       03 FILLER PIC X(40)
  73. 005400         VALUE '*---------------------------------------'.
  74. 005500       03 FILLER PIC X(40)
  75. 005600         VALUE '---------------------------------------*'.
  76. 005700*
  77. 005800 01 HD2.
  78. 005900     03 FILLER PIC X(09)             VALUE '|  FILE: '.
  79. 006000       03 HD2-FILE-NAME PIC X(12)        VALUE SPACES.
  80. 006100       03 FILLER PIC X(58)           VALUE SPACES.
  81. 006200     03 FILLER PIC X(01)             VALUE '|'.
  82. 006300*
  83. 006400 01 HD3.
  84. 006500     03 FILLER PIC X(09)             VALUE '| SAVED: '.
  85. 006600       03 HD3-FILE-DATE.
  86. 006700           05 HD3-FD-MM PIC 9(02).
  87. 006800         05 FILLER PIC X             VALUE '/'.
  88. 006900           05 HD3-FD-DD PIC 9(02).
  89. 007000         05 FILLER PIC X             VALUE '/'.
  90. 007100           05 HD3-FD-YY PIC 9(04).
  91. 007200     03 FILLER PIC X(04)             VALUE ' AT '.
  92. 007300       03 HD3-FILE-TIME.
  93. 007400           05 HD3-FT-HH PIC 9(02).
  94. 007500         05 FILLER PIC X             VALUE ':'.
  95. 007600           05 HD3-FT-MM PIC 9(02).
  96. 007700         05 FILLER PIC X             VALUE ':'.
  97. 007800           05 HD3-FT-SS PIC 9(02).
  98. 007900       03 FILLER PIC X(39)           VALUE SPACES.
  99. 008000     03 FILLER PIC X(05)             VALUE 'PAGE:'.
  100. 008100       03 HD3-PAGE-NBR PIC ZZZ9        VALUE ZEROS.
  101. 008200     03 FILLER PIC X(01)             VALUE '|'.
  102. 008300*
  103. 008400 01 HD4.
  104. 008500       03 FILLER PIC X(40)
  105. 008600         VALUE '*---------------------------------------'.
  106. 008700       03 FILLER PIC X(40)
  107. 008800         VALUE '---------------------------------------*'.
  108. 008900*
  109. 009000 01 HD5         PIC X(80)           VALUE SPACES.
  110. 009100*
  111. 009200 01 PAGE-CNT   PIC 9(4)           VALUE ZEROS.
  112. 009300 01 LINE-CNT   PIC 9(2)           VALUE 99.
  113. 009400 01 SEARCH-STATUS PIC X VALUE 'N'.
  114. 009500    88 EOF VALUE 'Y'.
  115. 009600*
  116. 009700 01 PARAMETER.
  117. 009800       03 PARM-LENGTH PIC S9(04) COMP-4.
  118. 009900       03 FILLER PIC X.
  119. 010000       03 PARM-CHARS.
  120. 010100           05 PARM-CHAR PIC X OCCURS 1 TO 120 TIMES
  121. 010200           DEPENDING ON PARM-LENGTH.
  122. 010300 EJECT
  123. 010400 PROCEDURE DIVISION.
  124. 010500*
  125. 010600 GET-PARM-STRING.
  126. 010700*
  127. 010800     CALL 'DOS_GET_PARMS' USING PARAMETER.
  128. 010900*
  129. 011000       IF PARM-LENGTH = 0
  130. 011100         DISPLAY 'FILE NAME MISSING - JOB TERMINATED'
  131. 011200           STOP RUN
  132. 011300       END-IF.
  133. 011400*
  134. 011500     STRING PARM-CHARS DELIMITED BY X'0D'
  135. 011600           LOW-VALUE DELIMITED BY SIZE
  136. 011700           INTO SEARCH-NAME.
  137. 011800*
  138. 011900       PERFORM FIND-FIRST.
  139. 012000       PERFORM FIND-NEXT UNTIL EOF.
  140. 012100       STOP RUN.
  141. 012200*
  142. 012300 FIND-FIRST SECTION.
  143. 012400*
  144. 012500 FF-01.
  145. 012600*
  146. 012700     CALL 'DOS_FIND_FIRST' USING SEARCH-NAME SEARCH-INFO.
  147. 012800*
  148. 012900       IF RETURN-CODE = 0
  149. 013000           MOVE FILE-NAME TO HD2-FILE-NAME INFILE-NAME
  150. 013100         EXAMINE HD2-FILE-NAME REPLACING ALL X'00' BY X'20'
  151. 013200           MOVE MONTHS TO HD3-FD-MM
  152. 013300           MOVE DAYS TO HD3-FD-DD
  153. 013400           MOVE YEARS TO HD3-FD-YY
  154. 013500           MOVE HOURS TO HD3-FT-HH
  155. 013600           MOVE MINUTES TO HD3-FT-MM
  156. 013700           MOVE SECONDS TO HD3-FT-SS
  157. 013800           PERFORM PROCESS-FILE
  158. 013900       ELSE
  159. 014000           STOP RUN
  160. 014100       END-IF.
  161. 014200*
  162. 014300 FIND-NEXT SECTION.
  163. 014400*
  164. 014500 FN-01.
  165. 014600*
  166. 014700     CALL 'DOS_FIND_NEXT' USING SEARCH-INFO.
  167. 014800*
  168. 014900       IF RETURN-CODE = 0
  169. 015000           MOVE FILE-NAME TO HD2-FILE-NAME INFILE-NAME
  170. 015100         EXAMINE HD2-FILE-NAME REPLACING ALL X'00' BY X'20'
  171. 015200           MOVE MONTHS TO HD3-FD-MM
  172. 015300           MOVE DAYS TO HD3-FD-DD
  173. 015400           MOVE YEARS TO HD3-FD-YY
  174. 015500           MOVE HOURS TO HD3-FT-HH
  175. 015600           MOVE MINUTES TO HD3-FT-MM
  176. 015700           MOVE SECONDS TO HD3-FT-SS
  177. 015800           PERFORM PROCESS-FILE
  178. 015900       ELSE
  179. 016000         MOVE 'Y' TO SEARCH-STATUS
  180. 016100       END-IF.
  181. 016200*
  182. 016300 PROCESS-FILE SECTION.
  183. 016400*
  184. 016500 PF-00.
  185. 016600*
  186. 016700       OPEN INPUT INFILE.
  187. 016800       OPEN OUTPUT OUTFILE.
  188. 016900*
  189. 017000 PF-10.
  190. 017100*
  191. 017200       READ INFILE AT END GO TO PF-99.
  192. 017300       IF LINE-CNT > 56
  193. 017400           PERFORM PF-20.
  194. 017500       WRITE OUTFILE-REC FROM INFILE-REC.
  195. 017600       ADD 1 TO LINE-CNT.
  196. 017700       GO TO PF-10.
  197. 017800*
  198. 017900 PF-20.
  199. 018000*
  200. 018100       ADD 1 TO PAGE-CNT.
  201. 018200       MOVE PAGE-CNT TO HD3-PAGE-NBR.
  202. 018300     IF LINE-CNT = '99'
  203. 018400           WRITE OUTFILE-REC FROM HD1
  204. 018500       ELSE
  205. 018600           WRITE OUTFILE-REC FROM HD1 AFTER ADVANCING PAGE
  206. 018700       END-IF.
  207. 018800       WRITE OUTFILE-REC FROM HD2.
  208. 018900       WRITE OUTFILE-REC FROM HD3.
  209. 019000       WRITE OUTFILE-REC FROM HD4.
  210. 019100       WRITE OUTFILE-REC FROM HD5.
  211. 019200       MOVE 5 TO LINE-CNT.
  212. 019300*
  213. 019400 PF-99.
  214. 019500*
  215. 019600       WRITE OUTFILE-REC FROM HD5 BEFORE ADVANCING PAGE.
  216. 019700       CLOSE INFILE.
  217. 019800       CLOSE OUTFILE.
  218. 019900       MOVE 99 TO LINE-CNT.
  219. 020000       MOVE 0 TO PAGE-CNT.
  220.